home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / turbgame.lbr / CRIBBAGE.PQS / CRIBBAGE.PAS
Pascal/Delphi Source File  |  1985-06-03  |  19KB  |  732 lines
  1. PROGRAM Cribbage;
  2.  
  3. (*  TURBO PASCAL 1.0
  4.     Morrow Micro Decision MD-2
  5.     David C. Oshel, Jan 15, 1984, 1219 Harding Ave, Ames, Iowa 50010
  6.     *)
  7.  
  8.  
  9. { TITLE PAGE:
  10. (':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
  11. (':: Adapted from "Cribbage" in APPLE PASCAL GAMES, by Douglas Hergert ::');
  12. (':: and Joseph T. Kalash, pages 301-349.  Sybex, 1981.                ::');
  13. ('::                                                                   ::');
  14. (':: January 8, 1984                                            d.c.o. ::');
  15. (':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
  16. }
  17.  
  18. Label 1;
  19.  
  20. Const
  21.   decksize   =   52;
  22.   dealsize   =    6;
  23.   scribsize  =    6;
  24.   playsize   =    4;
  25.   ranksize   =   13;
  26.   winpoints  =  121;
  27.  
  28. Type
  29.   charset    =  set of char;
  30.   str80      =  string[80];
  31.   suitype    =  (hearts,diamonds,clubs,spades);
  32.   ranktype   =  0..ranksize;
  33.  
  34.   card     = record
  35.                rank: ranktype;
  36.                suit: suitype
  37.              end;
  38.  
  39.   handtype = array[1..dealsize] of card;
  40.  
  41. {Typed} Const
  42.  
  43.   alpha:charset   = [' '..'}'];
  44.  
  45. Var
  46.   deck: array[1..decksize] of card;
  47.   comp,
  48.   human,
  49.   crib: handtype;
  50.   common: card;
  51.   i,
  52.   hscore,
  53.   cscore: integer;
  54.   ch: char;
  55.   xplayx: integer;
  56.  
  57. (*
  58. This is the code for simulating an Exit with TURBO Pascal 1.0
  59.  
  60. --> Include this instead of Exit(Procname) in the procedure which
  61.     actually invokes the exit:
  62.  
  63.          inline($2A/save/        { LD HL,(save)  ; EXIT PROC }
  64.                 $F9);            { LD SP,HL                  }
  65.          goto procend;
  66.  
  67. --> Include this as the FIRST instruction in the Procedure you wish
  68.     to eventually exit from:
  69.  
  70.          inline($21/0/0/         { LD HL,0000h   ; MARK PROC }
  71.                 $39/             { ADD HL,SP                 }
  72.                 $22/save);       { LD (save),HL              }
  73.  
  74. David C. Oshel, 15 January 1984, Ames, Iowa
  75. *)
  76.  
  77.  
  78. function getchar:char;
  79. var ch,cr,bs: char;
  80.     goodset: charset;
  81.     bailout: boolean;
  82. begin
  83.   cr:=chr(13); bs:=chr(8); goodset:=alpha+[cr,bs];
  84.   repeat
  85.     read(kbd,ch);
  86.     ch:=upcase(ch);
  87.     bailout:=(ch=chr(3)) or (ch=chr(27));
  88.     if eoln then ch:=cr
  89.   until bailout or (ch in goodset);
  90.   getchar:=ch;
  91.   if bailout then
  92.          inline($2A/xplayx/      { LD HL,(xplayx) ;EXIT PROC }
  93.                 $F9)             { LD SP,HL                  }
  94. end;  {getchar}
  95.  
  96. procedure getln(VAR s:str80);
  97. var ch: char;
  98.     done: boolean;
  99. begin
  100.   done:=false;
  101.   s:='';
  102.   repeat
  103.     ch:=getchar;
  104.     if (*  bailout or *) (ch=chr(13)) then
  105.       begin
  106.         done:=true;
  107.         writeln
  108.       end
  109.     else if ch=chr(8) then
  110.       begin
  111.         if length(s) > 0 then
  112.           begin
  113.             write(chr(8),' ',chr(8));
  114.             s:=copy(s,1,length(s)-1)
  115.           end
  116.         else s:=''
  117.       end
  118.     else
  119.       begin
  120.         s:=concat(s,ch);
  121.         if ch in alpha then write(ch)
  122.       end
  123.   until done;
  124. end;  {getln}
  125.  
  126.  
  127. procedure addpoints(who:boolean; amount:integer);
  128. var winner: boolean;
  129. begin
  130.   if who then
  131.     begin
  132.       hscore:=hscore+amount;
  133.       writeln('You''ve pegged ',hscore,' points.');
  134.       winner := (hscore >= winpoints)
  135.     end
  136.   else
  137.     begin
  138.       cscore:=cscore+amount;
  139.       writeln('I''ve pegged ',cscore,' points.');
  140.       winner := (cscore >= winpoints)
  141.     end;
  142.   if winner then
  143.          inline($2A/xplayx/      { LD HL,(xplayx) ;EXIT PROC }
  144.                 $F9)             { LD SP,HL                  }
  145. end; {addpoints}
  146.  
  147. {$I Cribbage.PS2}
  148.  
  149.  
  150. function getelement:integer;
  151. label retry;
  152. var irank,isuit: char;
  153.     rank: ranktype;
  154.     suit: suitype;
  155.     which: integer;
  156.     index: 1..dealsize;
  157.     many: -5..4;
  158.  
  159.     procedure getcard(VAR rankchar:char; VAR suitchar:char);
  160.     var ch: char;
  161.         s: str80;
  162.         i: integer;
  163.     begin
  164.       repeat
  165.         write('__',chr(8),chr(8));
  166.         getln(s);
  167.         rankchar:=' '; suitchar:=' ';
  168.         for i:=1 to length(s) do
  169.           begin
  170.             ch:=s[i];
  171.             if (ch in ['A','2'..'9','T','J','Q','K']) then rankchar:=ch;
  172.             if (ch in ['S','H','D','C']) then suitchar:=ch
  173.           end;
  174.         if (rankchar=' ') or (suitchar=' ') then
  175.           begin
  176.             writeln(s,'?');
  177.             writeln('Suits = S,H,D,C (Spades,Hearts,Diamonds,Clubs)');
  178.             writeln('Ranks = A,2,3,4,5,6,7,8,9,T,J,Q,K  (Ace is A, 10 is T!)');
  179.             writeln('Example: 8D (eight of Diamonds) or TH (ten of Hearts)');
  180.             writeln;
  181.             write('Try again from the start.  Which card? ')
  182.           end
  183.       until (rankchar<>' ') and (suitchar<>' ');
  184.       writeln('{{{ ',rankchar,suitchar,' }}}');
  185.     end;  {getcard}
  186.  
  187. begin
  188.   retry:
  189.   getcard(irank,isuit);
  190.   case irank of
  191.     'A': rank:=1;
  192.     '2','3','4','5','6','7','8','9': rank:=ord(irank)-ord('0');
  193.     'T': rank:=10;
  194.     'J': rank:=11;
  195.     'Q': rank:=12;
  196.     'K': rank:=13
  197.     end; {case}
  198.   case isuit of
  199.     'S': suit := spades;
  200.     'H': suit := hearts;
  201.     'D': suit := diamonds;
  202.     'C': suit := clubs
  203.     end; {case}
  204.   many:=0;
  205.   which:=0;
  206.   for index:=1 to dealsize do
  207.     begin
  208.       if human[index].rank = rank then
  209.         begin
  210.           many:=many+1;
  211.           if many>0 then which:=index;
  212.           if isuit<>' ' then
  213.           if human[index].suit = suit then
  214.           many:=-5
  215.         end
  216.     end;
  217.   if many=0 then
  218.     begin
  219.       writeln('What?!  No such card exists.');
  220.       write('Which card? ');
  221.       goto retry
  222.     end;
  223.   if many>1 then
  224.     begin
  225.       writeln('There is more than one ',irank);
  226.       write('Please be more specific:  ');
  227.       goto retry
  228.     end;
  229.   if (many=1) or (many<0) then getelement:=which;
  230. end;  {getelement}
  231.  
  232. procedure tocrib;
  233. var cardnum: 1..dealsize;
  234.     numgone: 0..1;
  235.  
  236. begin
  237.   for numgone:=0 to 1 do
  238.     begin
  239.       write('Throw which card? [ ');
  240.       for cardnum:=1 to (dealsize-numgone) do showcard(human[cardnum]);
  241.       write(' ] ');
  242.       cardnum:=getelement;
  243.       crib[numgone+1]:=human[cardnum];
  244.       while cardnum <= (dealsize-1) do
  245.         begin
  246.           human[cardnum]:=human[cardnum+1];
  247.           cardnum:=cardnum+1
  248.         end;
  249.       human[cardnum].rank:=0
  250.     end;
  251. end; {tocrib}
  252.  
  253. procedure sort(n:integer; var hand:handtype);
  254. var
  255.   touched: boolean;
  256.   index: 1..dealsize;
  257.   tmp: card;
  258.  
  259. begin
  260.   repeat
  261.     touched:=false;
  262.     for index:=1 to (n-1) do
  263.       if hand[index].rank > hand[index+1].rank then
  264.         begin
  265.           tmp:=hand[index];
  266.           hand[index]:=hand[index+1];
  267.           hand[index+1]:=tmp;
  268.           touched:=true
  269.           end
  270.   until not touched;
  271. end;  {sort}
  272.  
  273. {$I Cribbage.PS3}
  274.  
  275. procedure compcrib;
  276. type
  277.   bestrec = record
  278.               points: integer;
  279.               first, second: 1..dealsize
  280.             end;
  281. var
  282.   tmp: handtype;
  283.   best: bestrec;
  284.   i,j,points: integer;
  285.  
  286.   function compscore:integer;
  287.   var
  288.     index,points: integer;
  289.     num: 1..dealsize;
  290.   begin
  291.     num:=1;
  292.     for index:=1 to (i-1) do
  293.       begin
  294.         tmp[num]:=comp[index];
  295.         num:=num+1
  296.       end;
  297.     for index:=(i+1) to (j-1) do
  298.       begin
  299.         tmp[num]:=comp[index];
  300.         num:=num+1
  301.       end;
  302.     for index:=(j+1) to dealsize do
  303.       begin
  304.         tmp[num]:=comp[index];
  305.         num:=num+1
  306.       end;
  307.     tmp[5].rank:=0;
  308.     compscore:=score(tmp);
  309.   end; {function compscore}
  310.  
  311. begin {compcrib}
  312.   best.points:=-1;
  313.   sort(6,comp);
  314.   for i:=1 to (dealsize-1) do
  315.     for j:=i+1 to dealsize do
  316.       begin
  317.         points:=compscore;
  318.         if points > best.points then
  319.           begin
  320.             best.points:=points;
  321.             best.first:=i;
  322.             best.second:=j
  323.           end
  324.       end;
  325.   j:=1;
  326.   for i:=1 to (best.first-1) do
  327.     begin
  328.       tmp[j]:=comp[i];
  329.       j:=j+1
  330.     end;
  331.   for i:=(best.first+1) to (best.second-1) do
  332.     begin
  333.       tmp[j]:=comp[i];
  334.       j:=j+1
  335.     end;
  336.   for i:=(best.second+1) to dealsize do
  337.     begin
  338.       tmp[j]:=comp[i];
  339.       j:=j+1
  340.     end;
  341.   crib[3]:=comp[best.first];
  342.   crib[4]:=comp[best.second];
  343.   for i:=1 to playsize do comp[i]:=tmp[i];
  344. end;  {compcrib}
  345.  
  346.  
  347. procedure count(who: boolean);
  348. var
  349.   oldhuman: array[1..4] of card;
  350.   curcount: integer;
  351.   humcant,
  352.   compcant: boolean;
  353.   cnthand: array[1..8] of card;
  354.   last: 0..2;
  355.   cntnum: 1..8;
  356.   lastcnt: integer;
  357.   humleft,
  358.   comleft: 0..playsize;
  359.   i: -1..playsize;
  360.   points: integer;
  361.  
  362.   function countscore(newcard: card):integer;
  363.   var
  364.     return: integer;
  365.     matched, index: 0..8;
  366.   begin
  367.     return:=0; matched:=0;
  368.     cnthand[cntnum]:=newcard;
  369.     if cnthand[cntnum].rank > 10
  370.       then curcount:=curcount+10
  371.       else curcount:=curcount+cnthand[cntnum].rank;
  372.     if cntnum=1 then
  373.       begin
  374.         cntnum:=cntnum+1;
  375.         countscore:=0
  376.       end
  377.     else
  378.       begin
  379.         if (curcount=15) or (curcount=31) then return:=2;
  380.         index:=cntnum;
  381.         while index >= 2 do
  382.           begin
  383.             if cnthand[index].rank=cnthand[index-1].rank then
  384.               matched:=matched+1
  385.             else index:=1;
  386.             index:=index-1
  387.           end;
  388.         case matched of
  389.           0: ;
  390.           1: return:=return+2;
  391.           2: return:=return+6;
  392.           3: return:=return+12
  393.           end; {case}
  394.         matched:=0;
  395.         index:=cntnum;
  396.         while index >= 2 do
  397.           begin
  398.             if cnthand[index].rank=(cnthand[index-1].rank -1) then
  399.               matched:=matched+1
  400.             else index:=1;
  401.             index:=index-1
  402.           end;
  403.         cntnum:=cntnum+1;
  404.         if matched > 2 then return:=return+matched+1;
  405.         countscore:=return
  406.     end;
  407.   end;  {countscore}
  408.  
  409.   function humplay:integer;
  410.   var i,j: integer;
  411.   begin
  412.     if human[1].rank > 10 then i:=10
  413.     else i:=human[1].rank;
  414.     if (humleft <= 0) or ((i+curcount) > 31) then
  415.       begin
  416.         humcant:=true;
  417.         humplay:=-1
  418.       end
  419.     else
  420.       begin
  421.         last:=1;
  422.         humcant:=false;
  423.         if human[2].rank > 10 then i:=10
  424.         else i:=human[2].rank;
  425.         if (humleft=1) or ((i+curcount) > 31) then
  426.           humplay:=1
  427.         else
  428.           begin
  429.             j:=0;
  430.             while j=0 do
  431.               begin
  432.                 write('Play which card? [ ');
  433.                 for i:=1 to playsize do
  434.                   if human[i].rank <> 0 then showcard(human[i]);
  435.                   write(' ] ');
  436.                   i:=getelement;
  437.                   if human[i].rank > 10 then j:=10
  438.                   else j:=human[i].rank;
  439.                   if (j+curcount) > 31 then
  440.                     begin
  441.                       writeln('Sorry, that''s more than 31');
  442.                       j:=0
  443.                     end
  444.               end;
  445.             humplay:=i
  446.           end
  447.       end
  448.   end;  {humplay}
  449.  
  450.   function complay:integer;
  451.   var
  452.     index: 1..playsize;
  453.     points, best: integer;
  454.     tmp: 0..10;
  455.     return: 1..playsize;
  456.   begin
  457.     best:=-1;
  458.     if comp[1].rank > 10 then tmp:=10
  459.     else tmp:=comp[1].rank;
  460.     if (comleft=0) or ((tmp+curcount) > 31) then
  461.       begin
  462.         compcant:=true;
  463.         complay:=-1
  464.       end
  465.     else
  466.       begin
  467.         compcant:=false;
  468.         last:=2;
  469.         for index:=1 to comleft do
  470.           begin
  471.             if comp[index].rank>10 then tmp:=10
  472.             else tmp:=comp[index].rank;
  473.             if (tmp<>0) and ((tmp+curcount) <= 31) then
  474.               begin
  475.                 points:=countscore(comp[index]);
  476.                 cntnum:=cntnum-1;
  477.                 curcount:=curcount-tmp;
  478.                 if points>best then
  479.                   begin
  480.                     best:=points;
  481.                     return:=index
  482.                   end
  483.               end
  484.           end;
  485.         complay:=return
  486.       end;
  487.   end;  {complay}
  488.  
  489. begin {count -- at last!}
  490.   humleft:=playsize;
  491.   comleft:=playsize;
  492.   humcant:=false;
  493.   compcant:=false;
  494.   last:=0;
  495.   cntnum:=1;
  496.   if common.rank=11 then
  497.     begin
  498.       if who then
  499.         begin
  500.           writeln('I get a point for His Nibs!');
  501.           addpoints(false,1);
  502.         end
  503.       else
  504.         begin
  505.           writeln('YOU get a point for His Nibs!!');
  506.           addpoints(true,1);
  507.         end
  508.     end;
  509.   for curcount:=1 to playsize do
  510.     oldhuman[curcount]:=human[curcount];
  511.   curcount:=0;
  512.   while (humleft > 0) or (comleft > 0) do
  513.     begin
  514.       if who then
  515.         begin
  516.           who:=false;
  517.           i:=humplay;
  518.           if i>0 then
  519.             begin
  520.               write('You played a ');
  521.               showcard(human[i]);
  522.               writeln('.');
  523.               points:=countscore(human[i]);
  524.               if points>0 then
  525.                 begin
  526.                   writeln('You got ',points,' points');
  527.                   addpoints(true,points);
  528.                 end;
  529.               while i<=(playsize-1) do
  530.                 begin
  531.                   human[i]:=human[i+1];
  532.                   i:=i+1
  533.                 end;
  534.               human[humleft].rank:=0;
  535.               humleft:=humleft-1
  536.             end
  537.         end;
  538.       if not who then
  539.         begin
  540.           who:=true;
  541.           i:=complay;
  542.           if i>0 then
  543.             begin
  544.               write('I play a ');
  545.               showcard(comp[i]);
  546.               writeln('.');
  547.               points:=countscore(comp[i]);
  548.               if points>0 then
  549.                 begin
  550.                   writeln('I got ',points,' points.');
  551.                   addpoints(false,points);
  552.                 end;
  553.               while i <= (playsize-1) do
  554.                 begin
  555.                   comp[i]:=comp[i+1];
  556.                   i:=i+1
  557.                 end;
  558.               comp[comleft].rank:=0;
  559.               comleft:=comleft-1
  560.             end
  561.         end;
  562.       if lastcnt<>curcount then writeln('Total is ',curcount,'.');
  563.       lastcnt:=curcount;
  564.       if (humcant and compcant) or ((humleft=0) and (comleft=0)) then
  565.         begin
  566.           case last of
  567.             0: ;
  568.             1: begin
  569.                  writeln('You got a point for last card.');
  570.                  addpoints(true,1);
  571.                  who:=false
  572.                end;
  573.             2: begin
  574.                  writeln('I got a point for last card.');
  575.                  addpoints(false,1);
  576.                  who:=true
  577.                end
  578.             end; {case}
  579.           writeln;
  580.           writeln('Total is now 0.');
  581.           writeln;
  582.           humcant:=false;
  583.           compcant:=false;
  584.           last:=0;
  585.           cntnum:=1;
  586.           curcount:=0
  587.         end;
  588.     end;
  589.   for curcount:=1 to playsize do
  590.     human[curcount]:=oldhuman[curcount];
  591. end;  {count}
  592.  
  593.  
  594. procedure play(who: boolean);
  595. var
  596.   cpoints,
  597.   hpoints,
  598.   crbpnts: integer;
  599.   user:str80;
  600.   usernum,code: integer;
  601.  
  602.   procedure check(num: integer; question: str80);
  603.   begin
  604.     repeat
  605.       write(question);
  606.       getln(user);
  607.       val(user,usernum,code);
  608.       if code<>0
  609.         then writeln(user,'??')
  610.         else writeln;
  611.     until code=0;
  612.     if usernum<>num then
  613.       begin
  614.         writeln('Unless there''s a bug in my program, you should have taken ',num,' points!');
  615.         writeln('I get ',abs(num-usernum),', regardless!');
  616.         addpoints(false,abs(num-usernum));
  617.         if usernum>num then usernum:=num
  618.       end;
  619.     if (usernum > 0) then addpoints(true,usernum);
  620.     writeln;
  621.   end; {check}
  622.  
  623. begin {play}
  624.   inline($21/0/0/         { LD HL,0000h   ; MARK PROC }
  625.          $39/             { ADD HL,SP     ; FOR EXIT  }
  626.          $22/xplayx);     { LD (xplayx),HL            }
  627.  
  628.   repeat { forever -- we get out by simulating an Exit(Play) }
  629.       shuffle;
  630.       deal;
  631.       if who then writeln('It''s my crib.')
  632.       else writeln('It''s your crib.');
  633.       sort(6,human);
  634.       tocrib;
  635.       compcrib;
  636.       sort(4,crib);
  637.       if who then
  638.         begin
  639.           repeat
  640.             write('Cut which card [1-40] ? ');
  641.             getln(user);
  642.             val(user,usernum,code);
  643.             if code<>0
  644.               then writeln(user,'??')
  645.               else writeln
  646.           until (code=0) and (usernum in [1..40]);
  647.           common:=deck[usernum+12]
  648.         end
  649.       else
  650.         begin
  651.           common:=deck[13+random(40)]
  652.         end;
  653.       write('The UPCARD is ');
  654.       showcard(common);
  655.       writeln;
  656.       cpoints:=score(comp);
  657.       hpoints:=score(human);
  658.       crbpnts:=score(crib);
  659.       writeln;
  660.       count(who);
  661.       writeln;
  662.       if who then
  663.         begin
  664.           write('[ ');
  665.           for usernum:=1 to playsize do showcard(human[usernum]);
  666.           write(' ]  [ ');
  667.           showcard(common);
  668.           writeln(' ]');
  669.           check(hpoints,'How many points you got? ');
  670.           writeln('I''ve got ',cpoints,' points in my hand');
  671.           addpoints(false,cpoints);
  672.           writeln('I have ',crbpnts,' points in my crib');
  673.           addpoints(false,crbpnts);
  674.         end
  675.       else
  676.         begin
  677.           writeln('I''ve got ',cpoints,' in my hand');
  678.           addpoints(false,cpoints);
  679.           writeln;
  680.           write('[ ');
  681.           for usernum := 1 to playsize do showcard(human[usernum]);
  682.           write(' ]  [ ');
  683.           showcard(common);
  684.           writeln(' ]');
  685.           check(hpoints,'How many points in YOUR hand? ');
  686.           writeln;
  687.           write('[ ');
  688.           for usernum:=1 to playsize do showcard(crib[usernum]);
  689.           write(' ]  [ ');
  690.           showcard(common);
  691.           writeln(' ]');
  692.           check(crbpnts,'How much in the crib? ');
  693.         end;
  694.       who:=not who
  695.   until false
  696. end; {play}
  697.  
  698.  
  699. BEGIN  {MAIN}
  700.   1:
  701.   clrscr;
  702.   writeln(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
  703.   writeln('::       W E L C O M E   TO  K I D D I E   K R I B B A G E !         ::');
  704.   writeln('::                                                                   ::');
  705.   writeln(':: Adapted from "Cribbage" in APPLE PASCAL GAMES, by Douglas Hergert ::');
  706.   writeln(':: and Joseph T. Kalash, pages 301-349.  Sybex, 1981.                ::');
  707.   writeln('::                                                                   ::');
  708.   writeln(':: TURBO Pascal 1.0, Copyright 1983 by Borland Intl.    1/17/84  DCO ::');
  709.   writeln(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
  710.   writeln;
  711.   writeln('It''s you against me, kid!  Whoever pegs 121 points first wins!');
  712.   writeln;
  713.  
  714.   randomize;
  715.   makedeck;
  716.   hscore:=0;
  717.   cscore:=0;
  718.   play(random(2)=0);
  719.  
  720.   writeln;
  721.   if cscore>hscore
  722.     then writeln('Ho Ho!!  I peg out and win this game!')
  723.     else writeln('You pegged out and won the game!  Congratulations!');
  724.  
  725.   writeln; writeln; writeln;
  726.   write('Do you want another game? ');
  727.   read(kbd,ch); writeln(ch);
  728.   if ch in ['n','N']
  729.     then writeln('OK, see you later!')
  730.     else goto 1
  731. END.
  732.